Developer CD Series 2000 November: Tool Chest/Dev.CD Nov 00 TC Disk 1.toast/Sample Code/Networking/OTStreamLogViewer/IC Libraries/ICCommonSubs.p

Text File | 2000-09-28 | 42.9 KB | 1,402 lines | [TEXT/CWIE]

unit ICCommonSubs;

(*    This file is part of the Internet Configuration system and is placed in the public domain for the benefit of all.

    This file holds all those miscellaneous little functions that are basically wrappers
    around existing OS functionality.
*)

interface

    uses
        Files,
        Windows,
        Lists,
        AppleEvents,
        Menus,

        InternetConfig;

    (* ***** Event Manager Stuff ***** *)

    (* A collection of useful ASCII character definitions. *)
    const
        kNulChar            = chr($00);
        kHomeChar             = chr($01);
        kEnterChar             = chr($03);
        kEndChar             = chr($04);
        kHelpChar             = chr($05);
        kBackSpaceChar         = chr($08);
        kTabChar             = chr($09);
        kLineFeedChar         = chr($0A);
        kPageUpChar         = chr($0B);
        kPageDownChar         = chr($0C);
        kCRChar             = chr($0D);
        kEscChar             = chr($1B);
        kClearChar             = chr($1B);
        kLeftArrowChar         = chr($1C);
        kRightArrowChar     = chr($1D);
        kUpArrowChar         = chr($1E);
        kDownArrowChar        = chr($1F);
        kSpaceChar             = chr($20);
        kDelChar             = chr($7F);
        kBulletChar         = chr($A5);

    (* A collection of useful virtual key code definitions. *)
    const
        kUndoKeyCode         = 122;
        kCutKeyCode         = 120;
        kCopyKeyCode         = 99;
        kPasteKeyCode         = 118;
        kClearKeyCode         = 71;

        kEscKeyCode         = 53;
        kReturnKeyCode         = 36;
        kEnterKeyCode         = 52;
        kTabKeyCode         = 48;
        kSpaceKeyCode        = 49;
        KDeleteKeyCode         = 51;

        kCommandKeyCode     = 55;
        kShiftKeyCode         = 56;
        kCapsLockKeyCode     = 57;
        kOptionKeyCode         = 58;

    (* ***** Memory Stuff ***** *)

    const
        kHandleLockBit = 7;
        kHandlePurgeBit = 6;
        kHandleResourceBit = 5;

        kHandleLockMask = $80;
        kHandlePurgeMask = $40;
        kHandleResourceMask = $20;

    type
        (* A data structure for addresses memory as bytes. *)
        BigBuffer = packed array [0..$0FFFFFF] of Byte;
        BigBufferPtr = ^BigBuffer;
        BigBufferHandle = ^BigBufferPtr;

        (* Another for addressing memory as chars. *)
        BigCharArray = packed array [0..$FFFFFF] of char;
        BigCharArrayPtr = ^BigCharArray;
        BigCharArrayHandle = ^BigCharArrayPtr;

    function BlockCompare (lhsBaseAddr : univ Ptr; rhsBaseAddr: univ Ptr; size: longint): Boolean;
        (* Compares two blocks of memory for equality.*)

    procedure BlockFill (baseAddr: univ Ptr; size: longint; value: integer);
        (* Fills a block of memory with the value.  The memory is filled
            as bytes, ie the high byte of value is ignored.
        *)

    (* ***** Resource Manager Stuff ***** *)

    function CheckMemError(memoryHandle : univ Handle) : ICError;
    function CheckResError(resourceHandle : univ Handle) : ICError;

    function AddNamedResource(data : Handle; theType : ResType; const name : Str255) : ICError;
        (*    Adds data to the current resource file as a resource
            of type theType with the given name.  It calculates a
            unique resource ID for the newly added resource.  Note that,
            like AddResource, data comes back as either a resource
            handle (on noErr) or still a memory handle (on error).
        *)

    function Set1Resource(theData : Handle; theType : ResType; theID : integer) : OSStatus;
        (*    This routine sets the resource denoted by theType and theID to contain
            theData.  If the resource does not currently exist, it is created.
            If it does currently exist, it is modified.  theData is not disposed
            of.
        *)
    function Set1ResourcePtr(theData : univ Ptr; theDataSize : longint; theType : ResType; theID : integer) : OSStatus;
        (*    Works like Set1Resource except that you pass in a pointer and size. *)

    function Set1NamedResource(theData : Handle; theType : ResType; const name : Str255) : OSStatus;
        (*    This routine sets the resource denoted by theType and name to contain
            theData.  If the resource does not currently exist, it is created with
            a unique ID greater than 127.  If it does currently exist, it is modified.
            theData is not disposed of.
        *)

    (* ***** File Manager Stuff ***** *)

    function GetVolInfo (var ioName: Str63; var ioVRefNum: integer; ioVolIndex: integer;
                                        var ioVCrDate: longint): OSStatus;
        (* Returns information about the specified volume. Basically this is a wrapper
            around PBGetVInfo.  See IM:Files for a description of the meaning of the
            ioName, ioVRefNum and ioVolIndex parameters.  This routine also returns
            the volume's creation date in ioVCrDate to aid in Poor Man's Alias Manager
            volume matching.
        *)

    function FindApplicationInDTDB (creator: OSType; var foundApplicationSpec: FSSpec): OSStatus;
        (* This routine attempts to find an application in the desktop database
            given its creator type.
        *)

    function FSpGetCatInfo (var fss: FSSpec; ioFDirIndex: integer; var cpb: CInfoPBRec): OSStatus;
        (* This routine is a simple wrapper around PBGetCatInfo.  See IM:Files
            for a description of the meaning of ioFDirIndex.
            Note that, despite the name, this routine can be called under System 6.
        *)

    function FSpSetCatInfo (var fss: FSSpec; var cpb: CInfoPBRec): OSStatus;
        (* This routine is a simple wrapper around PBSetCatInfo.
            Note that, despite the name, this routine can be called under System 6.
        *)

    function FSpCatMoveQ(var fss : FSSpec; destDirID : longint) : OSStatus;
        (*    A nicer wrapper around PBCatMove.  FSpCatMove is a horrible
            routine because it requires a dest FSSpec, rather than
            a dest dirID.  CatMove is not good either because the
            Pascal interfaces define it to take a var:Str255 rather
            than a StringPtr, so you can't pass nil for ioNewName.
            So instead, we write our own.
        *)

    function FileLocked (const fss: FSSpec): Boolean;
        (* This routine returns true if the specified file is locked. Note that
            this provides no guarantee that you can write to the file; it merely
            checks all the things it can to see if any of them disable writing.
        *)

    function CopyFork (sourceForkRefnum, destForkRefnum: integer; bytesToCopy: longint): OSStatus;
        (* This routine copies a file fork from sourceForkRefnum to destForkRefnum.
            The files must be positioned at where you want to start copying (usually
            at the beginning) and the routine copys bytesToCopy bytes from the source
            to the destination.
        *)

    function CopyForkToFork (var sourceFile: FSSpec; var destFile: FSSpec;
                            sourceRsrc: Boolean; destRsrc: Boolean): OSErr;
        (* This routine copies a fork from the sourceFile to the destFile.
            The fork chosen in each case is determined by the sourceRsrc and
            destRsrc switches.  If true, the resource fork is used, if false,
            the data fork.
        *)

    function CopyFile (const source : FSSpec; const dest: FSSpec): OSStatus;
        (* Copies a file from source to dest.  Any file already existing at dest is
            destroyed.  Also set the catalogue info for the dest file from the source file.
        *)

    function GetFSSpecGivenFileRefNum(fileRefNum : integer; var fss : FSSpec) : OSStatus;
        (* Consults the FCB of the open file to find out its FSSpec. *)

    function FileRefNumIsWriteable(fileRefNum : integer; var writeable : Boolean) : OSStatus;
        (* Returns true if the FCB says that the file is writable. *)

    function EqualFSSpec(const fss1 : FSSpec; const fss2 : FSSpec) : Boolean;
        (* Returns true if fss1 and fss2 denote the same file system object. *)

    function ICUFSSpecToFullPath (const fss: FSSpec; var path: Str255): OSErr;
        (* Returns a full path for the given FSSpec.  Actually it's an approximation
            (it doesn't handle paths longer than 256 characters) but, seeing as
            IC only uses this path for display purposes, that's not a problem.
        *)

    function ICFileSpecToFSSpec (fileSpec: ICFileSpecHandle; canInteract: Boolean; var fss: FSSpec): ICError;
    function FSSpecToICFileSpec (var fss: FSSpec; fileSpec: ICFileSpecHandle): OSErr;
        (* These routines convert ICFileSpecHandles to FSSpecs and vice versa.
            An ICFileSpecHandle is basically an AliasHandle with some fields tacked
            on the front to make it usable by System 6 clients.  Under System 7 these
            routines are basically wrappers for standard Alias Manager routines.
            Note that in poth of these routines, the caller is responsible for allocating
            and deallocating the ICFileSpecHandle, and we just resize it if necessary.
        *)

    function IsApplicationType(fdType : OSType) : Boolean;
        (*    Returns true if fdType is common type for applications. *)

    (* ***** IC API Stuff ***** *)

    (* These are simple wrappers around the IC API for getting and setting PString preferences. *)

    function ICGetPrefStr (inst: ICInstance; key: Str255; var attr: ICAttr; var str: Str255): ICError;
    function ICSetPrefStr (inst: ICInstance; key: Str255; attr: ICAttr; str: Str255): ICError;

    (* ***** Text Utilities Stuff ***** *)

    (* These are simple wrappers around the toolbox NumToString and StringToNum routines. *)

    function DecStr(aNumber : longint): Str255;
    function DecVal(aString : Str255) : longint;

    (* These are simple routines to convert between strings and OSTypes. *)

    function StringToOSType (aString: Str255): OSType;
    function OSTypeToString (anOSType: OSType): Str15;

    function TPCopy (sourceString: string; startIndex : integer; count: integer): string;
        (* TPCopy provides a version of the Pascal built-in function Copy that
            implements the Think Pascal semantics.  This is much more useful
            than routine built-in to Metrowerks Pascal, which implements the
            semantics of MPW Pascal.
            The routine extracts count characters from the source string
            starting at character position start.  If there aren't enough characters
            in the string, it returns what there are.
        *)

    function GetOwnerName: Str255;
        (* This function returns the Owner name for the Macintosh
            as defined in the Sharing Setup control panel.
        *)

    function NewLookupError(NersID : integer; errNum : OSStatus) : Str255;
    (* Return the string associated with errNum.  The 'Ners' resource
        has a ResEdit template of...
                *****
                LSTB
                    errNum
                    DLNG
                    errstr
                    PSTR
                *****
                LSTE
        There must be a terminating entry with error number of 0 that contains
        the default error message.
    *)

    procedure NewLookupErrorC(NersID : integer; errNum : OSStatus; var result : Str255);
    (* A procedure version of the above, for access from lame C-like
        languages.
    *)

    (* ***** Truly Misc Stuff ***** *)

    function TrapAvailable (theTrap: integer): Boolean;
        (* Returns true if theTrap is available on this machine.
            This routine is implemented by the book, the book being Inside Macintosh.
        *)

    {$ifc not GENERATINGCFM}

    procedure MakeDataExecutableAs68KCode(base : Ptr; size : longint);
        (* Makes some data executable as 68K code.  This is distinct
            from the system call MakeDataExecutable, which makes data
            executable as PowerPC code.
           This call makes sense even on PPC machines, for example
              the old contents of the memory might be currently cached
              in the DR (Dynamic Recompiling) translation cache.
        *)

    {$endc}

    function ICUCanInteract: ICError;
        (* Returns noErr if user interaction is possible.  Basically a wrapper
            around AEInteractWithUser that makes it System 6 safe.
        *)

    procedure SafeAppendMenu (menuH: MenuHandle; itemText: Str255);
        (* The system AppendMenu interprets the new menu item in strange
            ways, attempting to glean command key and other information from
            the text.  This is obviously bad for things like the items on the
            Archie menu.  This 'safe' version of the AppendMenu routine
            sets the text window interpreting it.
        *)

implementation

    uses
        Icons,
        Errors,
        Resources,
        Dialogs,
        ToolUtils,
        Traps,
        LowMem,
        GestaltEqu,
        FSM,
        Script,
        TextUtils,

        InternetConfig,
        ICDebug;

    (* ***** Memory Stuff ***** *)

{$PUSH}
{$R-}
    function BlockCompare (lhsBaseAddr : univ Ptr; rhsBaseAddr: univ Ptr; size: longint): Boolean;
        (* See comment in interface part. *)
    begin
        BlockCompare := false;
        while (size > 0) do begin
            if lhsBaseAddr^ <> rhsBaseAddr^ then begin
                exit(BlockCompare);
            end; (* if *)
            inc(longint(lhsBaseAddr));
            inc(longint(rhsBaseAddr));
            size := size - 1;
        end; (* while *)
        BlockCompare := true;
    end; (* BlockCompare *)

    procedure BlockFill (baseAddr: univ Ptr; size: longint; value: integer);
        (* See comment in interface part. *)
    begin
        while (size > 0) do begin
            baseAddr^ := value;
            inc(longint(baseAddr));
            size := size - 1;
        end; (* while *)
    end; (* BlockFill *)
{$POP}

    (* ***** Resource Manager Stuff ***** *)

    function CheckMemError(memoryHandle : univ Handle) : ICError;
        var
            err : ICError;
    begin
        err := MemError;
        if err = noErr then begin
            ICAssert(memoryHandle <> nil);
            if memoryHandle = nil then begin
                err := memFullErr;
            end; (* if *)
        end; (* if *)
        CheckMemError := err;
    end; (* CheckMemError *)

    function CheckResError(resourceHandle : univ Handle) : ICError;
        var
            err : ICError;
    begin
        err := ResError;
        if err = noErr then begin
            if resourceHandle = nil then begin
                err := resNotFound;
            end; (* if *)
        end; (* if *)
        CheckResError := err;
    end; (* CheckResError *)

    function AddNamedResource(data : Handle; theType : ResType; const name : Str255) : ICError;
        var
            err : ICError;
            id : integer;
    begin
        repeat
            id := Unique1ID(theType);
        until id > 127;
        AddResource(data, theType, id, name);
        err := ResError;
        AddNamedResource := err;
    end; (* AddNamedResource *)

    function Set1Resource(theData : Handle; theType : ResType; theID : integer) : OSStatus;
        (*    This routine sets the resource denoted by theType and theID to contain
            theData.  If the resource does not currently exist, it is created.
            If it does currently exist, it is modified.  theData is not disposed
            of.
        *)
        var
            err : OSStatus;
            theDataSize : longint;
            oldData : Handle;
    begin
        theDataSize := GetHandleSize(theData);

        // Get the current contents of the resource.

        oldData := Get1Resource(theType, theID);
        err := CheckResError(oldData);
        if err = resNotFound then begin

            // There is currently no resource, add one that meets our needs.

            oldData := NewHandle(theDataSize);
            err := CheckMemError(oldData);
            if err = noErr then begin
                BlockMoveData(theData^, oldData^, theDataSize);
                AddResource(oldData, theType, theID, '');
                err := ResError;
                if err <> noErr then begin

                    // If AddResource failed, oldData is still a memory
                    // handle (ie it won't be cleaned up by the Resource Manager
                    // when the resource file is closed), so we need to clean it
                    // up ourselves.

                    DisposeHandle(oldData);
                    ICAssert(MemError = noErr);
                end; (* if *)
            end; (* if *)

        end else begin

            // There is current a resource, copy our data into it.

            SetHandleSize(oldData, theDataSize);
            err := MemError;
            if err = noErr then begin
                BlockMoveData(theData^, oldData^, theDataSize);
                ChangedResource(oldData);
                err := ResError;
            end; (* if *)

        end; (* if *)
        Set1Resource := err;
    end; (* Set1Resource *)

    function Set1ResourcePtr(theData : univ Ptr; theDataSize : longint; theType : ResType; theID : integer) : OSStatus;
        var
            err : OSStatus;
            tmpH : Handle;
    begin
        err := PtrToHand(theData, tmpH, theDataSize);
        if err = noErr then begin
            err := Set1Resource(tmpH, theType, theID);
            DisposeHandle(tmpH);
            ICAssert(MemError = noErr);
        end; (* if *)
        Set1ResourcePtr := err;
    end; (* Set1ResourcePtr *)

    function Set1NamedResource(theData : Handle; theType : ResType; const name : Str255) : OSStatus;
        (*    This routine sets the resource denoted by theType and name to contain
            theData.  If the resource does not currently exist, it is created with
            a unique ID greater than 127.  If it does currently exist, it is modified.
            theData is not disposed of.
        *)
        var
            err : OSStatus;
            theDataSize : longint;
            oldData : Handle;
    begin
        theDataSize := GetHandleSize(theData);

        // Get the current contents of the resource.

        oldData := Get1NamedResource(theType, name);
        err := CheckResError(oldData);
        if err = resNotFound then begin

            // There is currently no resource, add one that meets our needs.

            oldData := NewHandle(theDataSize);
            err := CheckMemError(oldData);
            if err = noErr then begin
                BlockMoveData(theData^, oldData^, theDataSize);
                err := AddNamedResource(oldData, theType, name);
                if err <> noErr then begin

                    // If AddNamedResource failed, oldData is still a memory
                    // handle (ie it won't be cleaned up by the Resource Manager
                    // when the resource file is closed), so we need to clean it
                    // up ourselves.

                    DisposeHandle(oldData);
                    ICAssert(MemError = noErr);
                end; (* if *)
            end; (* if *)

        end else begin

            // There is current a resource, copy our data into it.

            SetHandleSize(oldData, theDataSize);
            err := MemError;
            if err = noErr then begin
                BlockMoveData(theData^, oldData^, theDataSize);
                ChangedResource(oldData);
                err := ResError;
            end; (* if *)

        end; (* if *)
        Set1NamedResource := err;
    end; (* Set1NamedResource *)

    (* ***** File Manager Stuff ***** *)

    function GetVolInfo (var ioName: Str63; var ioVRefNum: integer; ioVolIndex: integer;
                                        var ioVCrDate: longint): OSStatus;
        (* See comment in interface part. *)
        var
            err: OSStatus;
            pb: ParamBlockRec;
    begin
        (* If we're trying to look up a volume by name, make sure there's a colon
            on the end of the name.
        *)
        if (ioName <> '') & (ioName[length(ioName)] <> ':') then begin
            ioName := concat(ioName, ':');
        end; (* if *)
        pb.ioNamePtr := @ioName;
        pb.ioVRefNum := ioVRefNum;
        pb.ioVolIndex := ioVolIndex;
        err := PBGetVInfoSync(@pb);
        if err = noErr then begin
            ioVRefNum := pb.ioVRefNum;
            ioVCrDate := pb.ioVCrDate;
        end; (* if *)
        GetVolInfo := err;
    end; (* GetVolInfo *)

    function FindApplicationInDTDB (creator: OSType; var foundApplicationSpec: FSSpec): OSStatus;
        (* See comment in interface part. *)
        var
            err: OSStatus;
            junkCreationDate: longint;
            volumeIndex: integer;
            pbdt: DTPBRec;
            found: Boolean;
    begin
        found := false;
        (* Repeat through each of the volumes in their enumeration order,
            querying the DTDB on each volume.
        *)
        volumeIndex := 1;
        repeat
            foundApplicationSpec.vRefNum := 0;
            foundApplicationSpec.name := '';
            err := GetVolInfo(foundApplicationSpec.name, foundApplicationSpec.vRefNum, volumeIndex, junkCreationDate);

            (* On this volume, attempt to find the application.  First get the path
                for the DTDB.
            *)
            if err = noErr then begin
                foundApplicationSpec.name := '';
                pbdt.ioNamePtr := @foundApplicationSpec.name;
                pbdt.ioVRefNum := foundApplicationSpec.vRefNum;
                err := PBDTGetPath(@pbdt);

                (* We have the path for the DTDB, now lookup the application in it. *)
                if err = noErr then begin
                    pbdt.ioIndex := 0;
                    pbdt.ioFileCreator := creator;
                    err := PBDTGetAPPLSync(@pbdt);
                    if err = noErr then begin
                        found := true;
                    end; (* if *)
                end; (* if *)

                (* Ignore errors from the DTDB, so we continue on with the next volume. *)
                err := noErr;
            end; (* if *)
            volumeIndex := volumeIndex + 1;
        until found or (err <> noErr);

        (* Clean up.  If we found the application, set the parID.  Otherwise return an
            innocuous FSSpec.
        *)
        if found then begin
            err := noErr;
            foundApplicationSpec.parID := pbdt.ioAPPLParID;
        end else begin
            err := afpItemNotFound;
            foundApplicationSpec.vRefNum := 0;
            foundApplicationSpec.parID := 2;
            foundApplicationSpec.name := '';
        end; (* if *)
        FindApplicationInDTDB := err;
    end; (* FindApplicationInDTDB *)

    function FSpGetCatInfo (var fss: FSSpec; ioFDirIndex: integer; var cpb: CInfoPBRec): OSStatus;
        (* See comment in interface part. *)
    begin
        cpb.ioVRefNum := fss.vRefNum;
        cpb.ioDirID := fss.parID;
        cpb.ioNamePtr := @fss.name;
        cpb.ioFDirIndex := ioFDirIndex;
        FSpGetCatInfo := PBGetCatInfoSync(@cpb);
    end; (* FSpGetCatInfo *)

    function FSpSetCatInfo (var fss: FSSpec; var cpb: CInfoPBRec): OSStatus;
        (* See comment in interface part. *)
    begin
        cpb.ioVRefNum := fss.vRefNum;
        cpb.ioDirID := fss.parID;
        cpb.ioNamePtr := @fss.name;
        FSpSetCatInfo := PBSetCatInfoSync(@cpb);
    end; (* FSpSetCatInfo *)

    function FSpCatMoveQ(var fss : FSSpec; destDirID : longint) : OSStatus;
        (* See comment in interface part. *)
        var
            cmpb : CMovePBRec;
    begin
        cmpb.ioNamePtr := @fss.name;
        cmpb.ioVRefNum := fss.vRefNum;
        cmpb.ioDirID := fss.parID;
        cmpb.ioNewName := nil;
        cmpb.ioNewDirID := destDirID;
        FSpCatMoveQ := PBCatMoveSync(@cmpb);
    end; (* FSpCatMoveQ *)

    function IsVolumeWriteable (vRefNum: integer): OSStatus;
        (* This routine returns noErr if the specified volume is writable,
            or an appropriate error otherwise.
        *)
        var
            err: OSStatus;
            pb: HParamBlockRec;
    begin
        pb.ioVRefNum := vRefNum;
        pb.ioNamePtr := nil;
        pb.ioVolIndex := 0;
        err := PBHGetVInfoSync(@pb);

        if err = noErr then begin
            if band(pb.ioVAtrb, $0080) <> 0 then begin
                err := wPrErr;            (* volume locked by hardware *)
            end else if band(pb.ioVAtrb, $8000) <> 0 then begin
                err := vLckdErr;            (* volume locked by software *)
            end; (* if *)
        end; (* if *)

        IsVolumeWriteable := err;
    end; (* IsVolumeWriteable *)

    function IsFileWriteable (fss: FSSpec): OSStatus;
        (* This routine returns noErr if the specified file is writeable,
            or an appropriate error otherwise.
        *)
        var
            err: OSStatus;
            cpb: CInfoPBRec;
    begin
        err := FSpGetCatInfo(fss, 0, cpb);
        if err = noErr then begin
            if band(cpb.ioFlAttrib, $01) <> 0 then begin
                err := fLckdErr;
            end; (* if *)
        end; (* if *)
        IsFileWriteable := err;
    end; (* IsFileWriteable *)

    function HGetDirAccess (ioVRefNum: integer; ioDirID: longint; ioName: StringPtr;
                                            var ownerID, groupID, accessRights: longint): OSStatus;
        (* This routine returns the directory access privileges for the specified directory. *)
        var
            err: OSStatus;
            pb: HParamBlockRec;
    begin
        pb.ioNamePtr := ioName;
        pb.ioVRefNum := ioVRefNum;
        pb.ioDirID := ioDirID;
        err := PBHGetDirAccessSync(@pb);
        ownerID := pb.ioACOwnerID;
        groupID := pb.ioACGroupID;
        accessRights := pb.ioACAccess;
        HGetDirAccess := err;
    end; (* HGetDirAccess *)

    function FileLocked (const fss: FSSpec): Boolean;
        (* See comment in interface part. *)
        var
            locked: Boolean;
            junk: longint;
            access: longint;
    begin
        locked := (IsVolumeWriteable(fss.vRefNum) <> noErr);
        if not locked then begin
            locked := (IsFileWriteable(fss) <> noErr);
        end; (* if *)
        if not locked then begin
            if HGetDirAccess(fss.vRefNum, fss.parID, nil, junk, junk, access) = noErr then begin
                locked := not btst(access, 26);
            end; (* if *)
        end; (* if *)
        FileLocked := locked;
    end; (* FileLocked *)

    function CopyFork (sourceForkRefnum, destForkRefnum: integer; bytesToCopy: longint): OSStatus;
        (*    See comments in interface part. *)
        const
            kMaxCopyBufferSize = 65536;
            kMinCopyBufferSize = 512;
        var
            err: OSStatus;
            copyBuffer: Ptr;
            copyBufferSize: longint;
            numberOfBytesThisTime: longint;
    begin
        (* First attempt to allocate a copy buffer.  We do this by attempting
            to allocate a buffer of size kMaxCopyBufferSize.  If that fails,
            we divide the size by two and try again.  We keep trying until
            the size drops below kMinCopyBufferSize, after which we
            give up and return an error.
        *)
        err := noErr;
        copyBufferSize := kMaxCopyBufferSize;
        copyBuffer := nil;
        repeat
            copyBuffer := NewPtr(copyBufferSize);
            if copyBuffer = nil then begin
                copyBufferSize := copyBufferSize div 2;
            end; (* if *)
        until (copyBuffer <> nil) or (copyBufferSize < kMinCopyBufferSize);
        if copyBuffer = nil then begin
            err := memFullErr;
        end; (* if *)

        (* Now copy the file data, in copyBufferSize chunks. *)
        while (err = noErr) & (bytesToCopy > 0) do begin
            numberOfBytesThisTime := copyBufferSize;
            if numberOfBytesThisTime > bytesToCopy then begin
                numberOfBytesThisTime := bytesToCopy;
            end; (* if *)
            err := FSRead(sourceForkRefnum, numberOfBytesThisTime, copyBuffer);
            if err = noErr then begin
                bytesToCopy := bytesToCopy - numberOfBytesThisTime;
                err := FSWrite(destForkRefnum, numberOfBytesThisTime, copyBuffer);
            end; (* if *)
        end; (* while *)

        (* Clean up. *)
        if copyBuffer <> nil then begin
            DisposePtr(copyBuffer);
        end; (* if *)
        CopyFork := err;
    end; (* CopyFork *)

    function CopyForkToFork (var sourceFile: FSSpec; var destFile: FSSpec;
                            sourceRsrc: Boolean; destRsrc: Boolean): OSErr;
        (*    See comments in interface part. *)
        var
            err: OSErr;
            srcRefNum: integer;
            destRefNum: integer;
            sizeofSrcFork: longint;
            junk: OSErr;
    begin
        (* Prepare for failure. *)
        srcRefNum := 0;
        destRefNum := 0;

        (* Open the source fork. *)
        if sourceRsrc then begin
            err := FSpOpenRF(sourceFile, fsRdPerm, srcRefNum);
        end else begin
            err := FSpOpenDF(sourceFile, fsRdPerm, srcRefNum);
        end; (* if *)
        if err <> noErr then begin
            srcRefNum := 0;
        end; (* if *)

        (* Open the dest fork. *)
        if err = noErr then begin
            if destRsrc then begin
                err := FSpOpenRF(destFile, fsRdWrPerm, destRefNum);
            end else begin
                err := FSpOpenDF(destFile, fsRdWrPerm, destRefNum);
            end; (* if *)
            if err <> noErr then begin
                destRefNum := 0;
            end; (* if *)
        end; (* if *)

        (* Set the length of the dest fork to the length of the source fork. *)
        if err = noErr then begin
            err := GetEOF(srcRefNum, sizeofSrcFork);
        end; (* if *)
        if err = noErr then begin
            err := SetEOF(destRefNum, sizeofSrcFork);
        end; (* if *)

        (* Copy the fork. *)
        if err = noErr then begin
            err := CopyFork(srcRefNum, destRefNum, sizeofSrcFork);
        end; (* if *)

        (* Clean up. *)
        if srcRefNum <> 0 then begin
            junk := FSClose(srcRefNum);
        end; (* if *)
        if destRefNum <> 0 then begin
            junk := FSClose(destRefNum);
        end; (* if *)

        junk := FlushVol(nil, destFile.vRefNum);

        CopyForkToFork := err;
    end; (* CopyForkToFork *)

    function CopyFile (const source : FSSpec; const dest: FSSpec): OSStatus;
        (* See comment in interface part. *)
        var
            err : OSStatus;
            junk: OSStatus;
            cpb: CInfoPBRec;
            tmpSource : FSSpec;
            tmpDest : FSSpec;
    begin
        tmpSource := source;
        tmpDest := dest;

        (* Start off by deleting the destination file. *)
        junk := FSpDelete(tmpDest);

        (* Copy both forks of the file. *)
        err := FSpGetCatInfo(tmpSource, 0, cpb);
        if err = noErr then begin
            err := FSpCreate(tmpDest, cpb.ioFlFndrInfo.fdCreator, cpb.ioFlFndrInfo.fdType, smSystemScript);
        end; (* if *)
        if err = noErr then begin
            err := CopyForkToFork (tmpSource, tmpDest, false, false);
        end; (* if *)
        if err = noErr then begin
            err := CopyForkToFork (tmpSource, tmpDest, true, true);
        end; (* if *)

        (* Set the catalogue info for the tmpDestination file. *)
        if err = noErr then begin
            err := FSpSetCatInfo(tmpDest, cpb);
        end; (* if *)

        (* Clean up.  Delete the file if we didn't succeed completely. *)
        if err <> noErr then begin
            junk := FSpDelete(tmpDest);
        end; (* if *)
        CopyFile := err;
    end; (* CopyFile *)

    function GetFSSpecGivenFileRefNum(fileRefNum : integer; var fss : FSSpec) : OSStatus;
        (* Consults the FCB of the open file to find out its FSSpec. *)
        var
            err : OSStatus;
            fcbPB : FCBPBRec;
    begin
        fcbPB.ioNamePtr := @fss.name;
        fcbPB.ioRefNum := fileRefNum;
        fcbPB.ioFCBIndx := 0;
        fcbPB.ioVRefNum := 0;
        err := PBGetFCBInfoSync(@fcbPB);
        if err = noErr then begin
            fss.vRefNum := fcbPB.ioFCBVRefNum;
            fss.parID := fcbPB.ioFCBParID;
        end; (* if *)
        GetFSSpecGivenFileRefNum := err;
    end; (* GetFSSpecGivenFileRefNum *)

    function FileRefNumIsWriteable(fileRefNum : integer; var writeable : Boolean) : OSStatus;
        (* See comment in interface part. *)
        var
            err : OSStatus;
            fcbPB : FCBPBRec;
    begin
        fcbPB.ioNamePtr := nil;
        fcbPB.ioRefNum := fileRefNum;
        fcbPB.ioFCBIndx := 0;
        fcbPB.ioVRefNum := 0;
        err := PBGetFCBInfoSync(@fcbPB);
        if err = noErr then begin
            writeable := band(fcbPB.ioFCBFlags, bsl(fcbWriteMask, 8)) <> 0;
        end; (* if *)
        FileRefNumIsWriteable := err;
    end; (* FileRefNumIsWriteable *)

    function EqualFSSpec(const fss1 : FSSpec; const fss2 : FSSpec) : Boolean;
        (* Returns true if fss1 and fss2 denote the same file system object. *)
    begin
        EqualFSSpec := (fss1.vRefNum = fss2.vRefNum) &
                        (fss1.parID = fss2.parID) &
                        EqualString(fss1.name, fss2.name, false, true);
    end; (* EqualFSSpec *)

    function ICUFSSpecToFullPath (const fss: FSSpec; var path: Str255): OSErr;
        (* See comment in interface part. *)
        var
            err: OSErr;
            pb: CInfoPBRec;
            tmpFSS : FSSpec;
    begin
        tmpFSS := fss;

        err := noErr;
        if tmpFSS.parID = 1 then begin
            (* It's a volume, just return the “name:”. *)
            path := concat(tmpFSS.name, ':');
        end else begin

            (* It's a file or folder, start by putting the name at the end of the path
                and then iterate up the directory hierarchy adding directory names to
                the front of the path.
            *)
            path := tmpFSS.name;
            while (err = noErr) & (tmpFSS.parID <> 1) do begin
                err := FSpGetCatInfo(tmpFSS, -1, pb);
                path := concat(tmpFSS.name, ':', path);
                tmpFSS.parID := pb.ioFlParID;
            end; (* while *)

        end; (* if *)
        ICUFSSPecToFullPath := err;
    end; (* ICUFSSPecToFullPath *)

    function FindVolumeByNameAndDate (name: Str31; creationDate: longint; var vRefNum: integer): OSErr;
        (* Attempts to find a volume based on it's name and creation date.  This
            is the tricky part of our "poor man's alias resolution" scheme.  An
            ICFileSpec stores the volume name and creation date of the item
            it points to.  These are used to try to find the matching volume
            in systems that don't have the Alias Manager.  This routine implements
            that finding code.

            The routine takes a two phase approach.  In the first phase, it searches for
            volumes by name and creation date.  If it can't find a match, it proceeds
            to the second phase where a matching name is considered good enough.

            Please don't blame me for the number of "leave"s in this code.  Peter
            wrote it, and I've learnt through hard experience that I'm too stupid
            to mess with his code too much.
        *)
        var
            err: OSErr;
            phase : (kMatchNameAndCreationDate, kMatchOnlyName);
            volumeName: Str255;
            volumeIndex: integer;
            pb: HParamBlockRec;
    begin
        for phase := kMatchNameAndCreationDate to kMatchOnlyName do begin

            volumeIndex := 1;
            while true do begin
                (* Get info an the volumeIndex'th volume. *)
                volumeName := '';
                pb.ioNamePtr := @volumeName;
                pb.ioVolIndex := volumeIndex;
                err := PBGetVInfoSync(@pb);
                if err <> noErr then begin
                    leave;
                end; (* if *)

                (* Check for a match. *)
                if EqualString(name, volumeName, false, true) then begin
                    if (phase = kMatchOnlyName) or (pb.ioVCrDate = creationDate) then begin
                        leave;
                    end; (* if *)
                end; (* if *)

                volumeIndex := volumeIndex + 1;
            end; (* while *)

            (* Leave if we found a match. *)
            if err = noErr then begin
                leave;
            end; (* if *)
        end; (* for *)

        (* Return the vRefNum of the found volume. *)
        if err = noErr then begin
            vRefNum := pb.ioVRefNum;
        end; (* if *)
        FindVolumeByNameAndDate := err;
    end; (* FindVolumeByNameAndDate *)

    function ICFileSpecToFSSpec (fileSpec: ICFileSpecHandle; canInteract: Boolean; var fss: FSSpec): ICError;
        (* See comment in interface part. *)
        var
            err: ICError;
            junkLong: longint;
            aliasH: AliasHandle;
            aliasCount: integer;
            aliasMatchRules: longint;
            junkBool: Boolean;
            cpb: CInfoPBRec;
    begin
        err := noErr;
        if (err = noErr) & (GetHandleSize(Handle(fileSpec)) < sizeof(ICFileSpec)) then begin
            err := paramErr;
        end; (* if *)

        if err = noErr then begin

            (* Try to find it using the alias embedded in the ICFileSpec. *)
            err := -1;
            if (fileSpec^^.alias.aliasSize <> 0) then begin
                (* Make a copy of the ICFileSpecHandle. *)
                aliasH := AliasHandle(fileSpec);
                err := HandToHand(Handle(aliasH));
                if err = noErr then begin
                    (* Use Munger to delete our fields from the front of the copy, thereby
                        turning it into a real AliasHandle.
                    *)
                    junkLong := Munger(Handle(aliasH), 0, nil, sizeof(ICFileSpec) - sizeof(AliasRecord), @junkLong, 0);

                    (* Call the Alias Manager to find the match. *)
                    aliasCount := 1;
                    aliasMatchRules := kARMSearch + kARMMountVol;
                    if canInteract & (ICUCanInteract <> noErr) then begin
                        aliasMatchRules := aliasMatchRules + kARMNoUI;
                    end; (* if *)
                    err := MatchAlias(nil, aliasMatchRules, aliasH, aliasCount, @fss, junkBool, nil, nil);

                    (* Dispose our copy of the alias. *)
                    DisposeHandle(Handle(aliasH));
                end; (* if *)
            end; (* if *)

            (* If it we didn't find it, try using our poor man's alias. *)
            if err <> noErr then begin

                (* Attempt to find a matching volume. *)
                err := FindVolumeByNameAndDate(fileSpec^^.vol_name, fileSpec^^.vol_creation_date, fss.vRefNum);

                (* If it worked, build an FSSpec for the item and confirm it's existance using
                    GetCatInfo.
                *)
                if err = noErr then begin
                    fss.parID := fileSpec^^.fss.parID;
                    fss.name := fileSpec^^.fss.name;
                    err := FSpGetCatInfo(fss, 0, cpb);
                end; (* if *)
            end; (* if *)
        end; (* if *)

        ICFileSpecToFSSpec := err;
    end; (* ICFileSpecToFSSpec *)

    function FSSpecToICFileSpec (var fss: FSSpec; fileSpec: ICFileSpecHandle): OSErr;
        (* See comment in interface part. *)
        var
            err: OSErr;
            pb: HParamBlockRec;
            volumeName: Str63;
            aliasH: AliasHandle;
            junkLong: longint;
    begin
        (* First resize the handle to the basic size and fill in our poor man's alias
            information.
        *)
        SetHandleSize(Handle(fileSpec), sizeof(ICFileSpec));
        err := MemError;
        if err = noErr then begin

            (* Get the volume information. *)
            volumeName := '';
            pb.ioNamePtr := @volumeName;
            pb.ioVRefNum := fss.vRefNum;
            pb.ioVolIndex := 0;
            err := PBGetVInfoSync(@pb);

            (* Fill in the basic fields of the ICFileSpec. *)
            if err = noErr then begin
                fileSpec^^.vol_creation_date := pb.ioVCrDate;
                fileSpec^^.vol_name := volumeName;
                fileSpec^^.fss := fss;
                fileSpec^^.alias.userType := OSType(0);
                fileSpec^^.alias.aliasSize := 0;
            end; (* if *)
        end; (* if *)

        (* Now, if we have the Alias Manager, create an alias and append it to the handle.
            This is entirely optional, so we make sure that any errors encountered in this
            process don't make it out to the client.
        *)
        if (err = noErr) then begin

            (* Create the alias. *)
            err := NewAlias(nil, fss, aliasH);
            if err = noErr then begin

                (* Append it to the end of the fileSpec and then delete the dummy
                    AliasRecord from the end of the original fileSpec.
                *)
                err := HandAndHand(Handle(aliasH), Handle(fileSpec));
                if err = noErr then begin
                    junkLong := Munger(Handle(fileSpec), sizeof(ICFileSpec) - sizeof(AliasRecord), nil, sizeof(AliasRecord), @junkLong, 0);
                end; (* if *)
                DisposeHandle(Handle(aliasH));
            end; (* if *)
            err := noErr;
        end; (* if *)

        FSSpecToICFileSpec := err;
    end; (* FSSpecToICFileSpec *)

    function IsApplicationType(fdType : OSType) : Boolean;
        (* See comment in interface part. *)
    begin
        // If you add extra types, you should also make a similar change
        // in ICStandardGetFile in "ICStandardFile.p".

        IsApplicationType := (fdType = 'APPL') | (fdType = 'APPC') | (fdType = 'appe');
    end; (* IsApplicationType *)

    (* ***** IC API Stuff ***** *)

{$PUSH}
{$R-}
    function ICGetPrefStr (inst: ICInstance; key: Str255; var attr: ICAttr; var str: Str255): ICError;
        (* See comment in interface part. *)
        var
            err: ICError;
            size: longint;
    begin
        size := 256;
        err := ICGetPref(inst, key, attr, @str, size);
        if err <> noErr then begin
            str := '';
        end; (* if *)
        ICGetPrefStr := err;
    end; (* ICGetPrefStr *)

    function ICSetPrefStr (inst: ICInstance; key: Str255; attr: ICAttr; str: Str255): ICError;
        (* See comment in interface part. *)
    begin
        ICSetPrefStr := ICSetPref(inst, key, attr, @str, length(str) + 1);
    end; (* ICSetPrefStr *)
{$POP}

    (* ***** Text Utilities Stuff ***** *)

    function DecStr(aNumber: longint): Str255;
        (* See comment in interface part. *)
        var
            result : Str255;
    begin
        NumToString(aNumber, result);
        DecStr := result;
    end; (* DecStr *)

    function DecVal(aString : Str255) : longint;
        (* See comment in interface part. *)
        var
            result : longint;
    begin
        StringToNum(aString, result);
        DecVal := result;
    end; (* DecVal *)

    function StringToOSType (aString: Str255): OSType;
        (* See comment in interface part. *)
        var
            result: OSType;
    begin
        aString := concat(aString, chr(0), chr(0), chr(0), chr(0));
        BlockMoveData(@aString[1], @result, 4);
        StringToOSType := result;
    end; (* StringToOSType *)

    function OSTypeToString (anOSType: OSType): Str15;
        (* See comment in interface part. *)
        var
            result : Str15;
    begin
        result := concat(chr(0),chr(0),chr(0),chr(0));
        BlockMoveData(@anOSType, @result[1], 4);
        OSTypeToString := result;
    end; (* OSTypeToString *)

    function TPCopy (sourceString: string; startIndex : integer; count: integer): string;
        (* See comment in interface part. *)
    begin
        (* Check for startIndex being before the first character in the string. *)
        if startIndex < 1 then begin
            count := count - (1 - startIndex);
            startIndex := 1;
        end; (* if *)

        (* Check for a request for more characters than are in the string. *)
        if (startIndex + count) > length(sourceString) then begin
            count := length(sourceString) - startIndex + 1;
        end; (* if *)

        (* Trim count. *)
        if count < 0 then begin
            count := 0;
        end; (* if *)

        (* Extract the string data. *)
        sourceString[0] := chr(count);
        BlockMoveData(@sourceString[startIndex], @sourceString[1], count);

        TPCopy := sourceString;
    end; (* TPCopy *)

    function GetOwnerName : Str255;
        (* See comment in interface part. *)
        const
            rOwnerNameString = -16096;
        var
            strH: StringHandle;
    begin
        strH := GetString(rOwnerNameString);
        if strH <> nil then begin
            (* Don't release it, someone else might be using it. *)
            GetOwnerName := strH^^;
        end else begin
            GetOwnerName := '';
        end; (* if *)
    end; (* GetOwnerName *)

    function NewLookupError(NersID : integer; errNum : OSStatus) : Str255;
        (* See comment in interface part. *)
        var
            result : Str255;
            errH : Handle;
            s : SInt8;
            candidateErrNum : longint;
            errsDataPtr : BigBufferPtr;
            indexIntoErrsData : longint;
            maxIndexIntoErrsData : longint;
            found : Boolean;
    begin
        result := '';
        errH := GetResource('Ners', NersID);
        if errH <> nil then begin
            s := HGetState(errH);
            HLock(errH);
            errsDataPtr := BigBufferPtr(errH^);

            indexIntoErrsData := 0;
            maxIndexIntoErrsData := GetHandleSize(errH);
            found := false;
            (* Loop through the resource looking for a match. *)
            while (indexIntoErrsData < maxIndexIntoErrsData) and not found do begin
                (* Extract the error number.
                     I use BlockMoveData here because the data may not be word aligned, and
                        original 68Ks will take an Address Error if I attempt to move an
                        unaligned longint.
                *)
                BlockMoveData(@errsDataPtr^[indexIntoErrsData], @candidateErrNum, sizeof(longint));
                indexIntoErrsData := indexIntoErrsData + sizeof(longint);

                (* Extract the error string. *)
                BlockMoveData(@errsDataPtr^[indexIntoErrsData], @result, errsDataPtr^[indexIntoErrsData] + 1);
                indexIntoErrsData := indexIntoErrsData + errsDataPtr^[indexIntoErrsData] + 1;

                (* Figure out whether we've found what we're looking for. *)
                found := (candidateErrNum = errNum) or (candidateErrNum = 0)
            end; (* while *)

            if not found then begin
                result := '';
            end; (* if *)
            HSetState(errH, s);
        end; (* if *)
        NewLookupError := result;
    end; (* NewLookupError *)

    procedure NewLookupErrorC(NersID : integer; errNum : OSStatus; var result : Str255);
        (* See comment in interface part. *)
    begin
        result := NewLookupError(NersID, errNum);
    end; (* NewLookupErrorC *)

    (* ***** Truly Misc Stuff ***** *)

    function NumToolboxTraps: integer;
        (* Returns the number of toolbox traps on this machine. *)
    begin
        if NGetTrapAddress(_InitGraf, ToolTrap) = NGetTrapAddress($AA6E, ToolTrap) then begin
            NumToolboxTraps := $200
        end else begin
            NumToolboxTraps := $400;
        end; (* if *)
    end; (* NumToolboxTraps *)

    function GetTrapType (theTrap: integer): TrapType;
        (* Returns the trap type associated with the given A-Trap number. *)
        const
            TrapMask = $0800;
    begin
        if band(theTrap, TrapMask) > 0 then begin
            GetTrapType := ToolTrap
        end else begin
            GetTrapType := OSTrap;
        end; (* if *)
    end; (* GetTrapType *)

    function TrapAvailable (theTrap: integer): Boolean;
        (* See comment in interface part. *)
        var
            tType: TrapType;
    begin
        tType := GetTrapType(theTrap);
        if tType = ToolTrap then begin
            theTrap := band(theTrap, $07FF);
            if theTrap >= NumToolboxTraps then begin
                theTrap := _Unimplemented;
            end; (* if *)
        end; (* if *)
        TrapAvailable := NGetTrapAddress(theTrap, tType) <> NGetTrapAddress(_Unimplemented, ToolTrap);
    end; (* TrapAvailable *)

    {$ifc not GENERATINGCFM}

    (*    Some utter gumby forgot that you might want to generate
        68K code from a PPC binary, and so FlushCodeCacheRange is
        not exported to CFM clients.  You can write your own glue,
        but in the case of IC it's just simpler to comment out the code
        for PPC builds because I don't need this functionality from
        my PPC code.
    *)

    (*    Some utter gumby forgot that FlushCodeCacheRange is supposed
        to return an error code, and defined it wrong in the Universal
        Interfaces.  This error is *finally* fixed in version 3.x
        of the interfaces, but we're using 2.x at the moment, so we
        still have to define our own.

        By the way, we define this EXTERNAL if we're building CFM,
        so that the compiler doesn't complain about the fact we
        don't implement the CFM side of it (which is kinda tricky).
        That puts off the error until link time.  If I find that
        I actually need to call this from CFM code, I guess
        I'll have to knuckle down and write the glue.
    *)

    FUNCTION QFlushCodeCacheRange(address: UNIV Ptr; count: LONGINT) : OSErr;
        {$IFC NOT GENERATINGCFM}
        INLINE $225F, $205F, $7009, $A098, $3E80;
        {$ELSEC}
        EXTERNAL;
        {$ENDC}

    procedure MakeDataExecutableAs68KCode(base : Ptr; size : longint);
    begin
        if TrapAvailable(_HWPriv) then begin
            if QFlushCodeCacheRange(base, size) <> noErr then begin
                FlushCodeCache;
            end; (* if *)
        end; (* if *)
    end; (* MakeDataExecutableAs68KCode *)

    {$endc}

    function ICUCanInteract: ICError;
        (* See comment in interface part. *)
        var
            err: ICError;
            gestaltResponse : longint;
    begin
        err := noErr;
        if (Gestalt(gestaltAppleEventsAttr, gestaltResponse) = noErr) &
                                    btst(gestaltResponse, gestaltAppleEventsPresent) then begin
            err := AEInteractWithUser(kAEDefaultTimeout, nil, nil);
        end; (* if *)
        ICUCanInteract := err;
    end; (* ICUCanInteract *)


    procedure SafeAppendMenu (menuH: MenuHandle; itemText: Str255);
        (* See comment in interface part. *)
    begin
        AppendMenu(menuH, 'fred');

        // If the string begins with a '-', we must change it
        // before calling SetMenuItemText because the system inteprets
        // a leading '-' as a disabled item, even in SetMenuItemText.
        // This code is WorldScript safe because the first byte of
        // the string is either a) the first byte of a two byte
        // character, in which case it must be high bit set character,
        // and '-' isn't, b) a single byte character, in which case
        // the comparison makes sense because all script systems
        // contain Roman as the first 128 values of the one byte
        // characters.

        if (length(itemText) > 0) & (itemText[1] = '-') then begin
            itemText[1] := chr(0);
        end; (* if *)

        SetMenuItemText(menuH, CountMItems(menuH), itemText);
    end; (* SafeAppendMenu *)

end. (* ICCommonSubs *)